home *** CD-ROM | disk | FTP | other *** search
Text File | 1992-08-16 | 19.8 KB | 552 lines | [TEXT/CCL2] |
- ;;;
- ;;; resource-utils.Lisp
- ;;;
-
- #|
- ================================================================
- Purpose ========================================================
- ================================================================
- Defines a LISP-style error-checked interface to the Resource Manager. The
- function definitions are organized as in Inside Macintosh VI.
-
- Copyright © 1990-92 Matthew Cornell. All Rights Reserved. Send
- bugs, comments, questions, and fixes to cornell@cs.umass.edu.
-
-
- ================================================================
- Status =========================================================
- ================================================================
- Implemented for both 1.3.2 and 2.0b.
-
- To do:
-
- Return (#_ResError) ?
-
- Implement other resource manager functions.
-
- Provide a restart for open-resource-file to handle the file not being
- found.
-
- Get-resource should check for NIL being returned (ie it failed) and use
- resource-error for the specific error:
-
- More/better error checking (for example get-resource-info should check the
- returned value using resource-error)
-
-
- ================================================================
- Change history =================================================
- ================================================================
- 22-Jan-90 mc Created (Matthew Cornell).
- 6-Jul-90 mc Changed functions passing ostypes to use :ostype
- type keyword. <- didn't work:
-
- ? (_CountResources :ostype "PICT" :word)
- 2
- ? (let ((type "PICT")) (_CountResources :ostype type :word))
- 0
-
- 6-jul-90 mc Fixed get-indexed-type
- 12-jul-90 mc Added get-named-resource and load-resource
- 8-aug-90 mc Added size-resource and get-resource-info
- Added check-h-resource
- Added test/sample code at end
- Modified open-resource-file to use *open-resource-files*. This
- allows enables closing all resource files (passing 0 to
- close-resource-file) and allows close-resource-file to take either
- a ref-num or the original file.
- Using CCL package.
- 28-aug-90 mc Added print-info-resource-type and print-info-all-resource-types
- (removed from commented demo code ), and exported them.
- 2-Jul-91 mc Added conditionalization for :CCL-1 and :CCL-2.
- 3-Jul-91 mc Defined current-resource-file and use-resource-file.
- 3-Jul-91 mc Defined create-resource-file.
- 14-Dec-91 mc Changed name to Resource-utils.Lisp to avoid a conflict with
- Apple's resources.Lisp (for version 2.0ß4).
- 14-Jan-92 mc Defined reopen-resource-files, which is saved on
- *restore-lisp-functions* so that open resource files will be
- reopened when images are restarted. Issue: should
- open-resource-file push the pathname it was passed or the full
- pathname onto *open-resource-files* ? Decided on the passed
- one.
- 30-Jan-92 mc Added (reverse *open-resource-files*) to reopen-resource-files
- so that the would be reopened in the right order.
- 29-Feb-92 mc Defined get-resource-smart .
- 19-Mar-92 mc Removed traps requirement (now uses less memory but
- 2.0-dependent).
- 29-Mar-92 mc Defined and exported with-resource-file, update-resource-file,
- add-resource, remove-resource .
- Cleaned up the alist-entry adt.
- 16-Jul-92 mc Changed open-resource-file to require a string for file-name
- because it errored on pathnames.
- 19-Jul-92 mc Changed open-resource-file back to a defun (it was causing an
- error when it clashed with Apple's version, which was not a
- generic function).
- 21-Jul-92 mc Defined close-all-resource-files, as suggested by
- neves@ils.nwu.EDU (thank you!).
- Incorporated count1-resources and get1-indexed-resource, sent by
- neves@ils.nwu.EDU .
- Converted to using keywords to name resource types instead
- of strings. This is consistent with mcl2.0's use of
- resource types (for example %get-ostype returns a keyword), but
- is a compatibility break. Case is significant when identifying
- resource types; use :|snd |, :|PICT|, etc. to keep keywords in
- their case.
- Removed first-resource-word and second-resource-word . The
- functionality is handled directly by 2.0's improved trap call
- mechanism.
- 16-Aug-92 mc SERIOUS problem: turning on balloon help causes errors because
- it calls the old open-resource-file. In general we can't
- shadow Apple's functions because mcl depends on them.
- Solution1: Put all these files in a "RESOURCE-UTILS"
- package. Solution2: change this file's functions names.
- Decision: Use Solution1, knowing it's a compatibility break:
- Changed package to "RESOURCE-UTILS" .
- Fixed provide to use "RESOURCE-UTILS" (conflicted with Apple's).
- Removed "CCL" from "RESOURCE-UTILS"'s :use list, to fix conflict.
-
- |#
-
-
-
- (in-package "CL-USER") ;temporary so we won't get a no
- ; package error
-
-
- ;;; Define the package.
-
- (defpackage "RESOURCE-UTILS" (:nicknames "RU")
- (:use "COMMON-LISP")
- (:shadow OPEN-RESOURCE-FILE CLOSE-RESOURCE-FILE USE-RESOURCE-FILE
- CURRENT-RESOURCE-FILE GET-RESOURCE LOAD-RESOURCE ADD-RESOURCE
- REMOVE-RESOURCE))
-
-
- (in-package "RESOURCE-UTILS")
-
-
- (export '(RESOURCE-ERROR
- CREATE-RESOURCE-FILE
- OPEN-RESOURCE-FILE
- CLOSE-RESOURCE-FILE
- CLOSE-ALL-RESOURCE-FILES
- WITH-RESOURCE-FILE
- CURRENT-RESOURCE-FILE
- USE-RESOURCE-FILE
- COUNT-TYPES
- GET-INDEXED-TYPE
- COUNT-RESOURCES
- GET-INDEXED-RESOURCE
- GET-RESOURCE
- GET-RESOURCE-SMART
- GET-NAMED-RESOURCE
- LOAD-RESOURCE
- COUNT1-RESOURCES
- GET1-INDEXED-RESOURCE
- GET-RESOURCE-INFO
- SIZE-RESOURCE
- ADD-RESOURCE
- REMOVE-RESOURCE
- UPDATE-RESOURCE-FILE
- ;;
- PRINT-INFO-RESOURCE-TYPE
- PRINT-INFO-ALL-RESOURCE-TYPES)
- "RU")
-
-
- ;;;====================================================================
- ;;;Parameters =========================================================
- ;;;====================================================================
-
- (defvar *open-resource-files* ()
- "An alist of the form ((pathname1 . ref-num1) ...) managed by
- open-resource-file, close-resource-file, and reopen-resource-files . Each
- pathname is the namestring as passed to open-resource-file, not the
- expanded pathname.")
-
-
- ;;;====================================================================
- ;;;Checking for errors ================================================
- ;;;====================================================================
-
- (defun resource-error ()
- "Used by some resource functions; 0 means no error."
- ;;
- (#_ResError :word))
-
-
- (defmacro check-resource-type (kw-resource-type)
- "Ensures kw-resource-type is a keyword whose string is 4 characters long
- and errors if it isn't."
- ;;
- `(unless (and (keywordp ,kw-resource-type)
- (= (length (string ,kw-resource-type)) 4))
- (error "~S not a proper resource type" ,kw-resource-type)))
-
-
- (defmacro check-h-resource (h-resource)
- "Ensures h-resource is handlep, calling error if not."
- ;;
- `(unless (ccl::handlep ,h-resource)
- (error "~S not a handle" ,h-resource)))
-
-
- ;;;====================================================================
- ;;;Support functions ==================================================
- ;;;====================================================================
-
- (defmacro full-file-name (str-file-name)
- `(namestring (ccl::full-pathname ,str-file-name)))
-
-
- ;;;====================================================================
- ;;;Define functions for handling the alist-entry abstract data type. ==
- ;;;====================================================================
-
- (defun make-alist-entry (string-filename int-ref-num)
- "Returns a new alist-entry that encodes string-filename and int-ref-num."
- ;;
- (cons string-filename int-ref-num))
-
-
- (defun filename-alist-entry (alist-entry)
- "Returns alist-entry's filename."
- ;;
- (car alist-entry))
-
-
- (defun refnum-alist-entry (alist-entry)
- "Returns alist-entry's refnum."
- ;;
- (cdr alist-entry))
-
-
- (defun refnum/filename->alist-entry (refnum-or-filename)
- "Returns the alist-entry on *open-resource-files* corresponding to
- refnum-or-filename, which is an integer or a string. Errors if
- refnum-or-filename identifies a file that does not identify an entry on
- *open-resource-files* ."
- ;;
- (let ((alist-entry
- (etypecase refnum-or-filename
- (integer (rassoc refnum-or-filename *open-resource-files*))
- ;; Following was (full-file-name refnum-or-filename):
- (string (assoc refnum-or-filename
- *open-resource-files* :test #'equal)))))
- (unless alist-entry
- (error "~S does not identify a resource file opened by open-resource-file."
- refnum-or-filename))
- alist-entry))
-
-
- ;;;====================================================================
- ;;;Opening and closing resource files =================================
- ;;;====================================================================
-
- ;;;
- ;;; Interesting note: this dies (infinite GC) on HyperCard:
- ;;;
-
- (defun create-resource-file (str-file-name)
- "CreateResFile creates a resource file containing no resource data. If
- there's no file at all with the given name, it also creates an empty data
- fork for the file. If there's already a resource file with the given name
- \(that is, a resource fork that isn't empty), CreateResFile will do nothing
- and the ResError function will return an appropriate Operating System
- result code."
- ;;
- (ccl::with-pstrs ((file-name-ptr (full-file-name str-file-name)))
- (#_CreateResFile :ptr file-name-ptr)))
-
-
- (defun open-resource-file (str-file-name)
- "Opens the resource fork of str-file-name, saving the str-file-name
- and the reference number on *open-resource-files*. Returns ref-num with
- -1 meaning the file couldn't be opened. str-file-name is a logical or
- full pathname."
- ;;
- (check-type str-file-name string)
- ;;
- (let* ((full-file-name (full-file-name str-file-name))
- (ref-num (ccl::with-pstrs ((file-name-ptr full-file-name))
- (#_OpenResFile :ptr file-name-ptr :word))))
- ;;
- ;; Remove any old dotted pairs corresponding to str-file-name and add a new
- ;; one, if the file was opened successfully.
- ;;
- (unless (= ref-num -1)
- (when (assoc str-file-name *open-resource-files* :test #'equal)
- (setf *open-resource-files*
- (remove-if #'(lambda (open-file-name)
- (string-equal open-file-name str-file-name))
- *open-resource-files* :key #'filename-alist-entry)))
- ;; Following was (cons full-file-name ref-num):
- (push (make-alist-entry str-file-name ref-num)
- *open-resource-files*))
- ref-num))
-
-
- (defun close-resource-file (refnum-or-filename)
- "Closes the resource fork of the file corresponding to refnum-or-filename,
- returning a the result of resource-error."
- ;;
- (let* ((alist-entry (refnum/filename->alist-entry refnum-or-filename))
- (int-refnum (refnum-alist-entry alist-entry)))
- (setf *open-resource-files*
- (if (zerop int-refnum)
- ()
- (remove alist-entry *open-resource-files* :test #'equal)))
- (#_CloseResFile :word int-refnum)
- (resource-error)))
-
-
- (defun close-all-resource-files ()
- "Calls close-resource-file on all open resource files."
- ;;
- (dolist (alist-entry *open-resource-files*)
- (close-resource-file (refnum-alist-entry alist-entry))))
-
-
- ;;;====================================================================
- ;;;Setting the current resource file ==================================
- ;;;====================================================================
-
- (defmacro with-resource-file ((refnum-or-filename) &rest body)
- "Executes body with the current resource file set to refnum-or-filename
- via use-resource-file. An unwind-protect resets the current resource
- file to what it was."
- ;;
- (let ((sym-temp (gentemp)))
- `(let ((,sym-temp (current-resource-file)))
- (unwind-protect
- (progn
- (use-resource-file ,refnum-or-filename)
- ,@body)
- (use-resource-file ,sym-temp)))))
-
-
- (defun current-resource-file ()
- "CurResFile returns the reference number of the current resource file."
- ;;
- (#_CurResFile :word))
-
-
- (defun use-resource-file (refnum-or-filename)
- "Given the reference number of a resource file, UseResFile sets the
- current resource file to that file. If there's no resource file open with
- the given reference number, UseResFile will do nothing and the ResError
- function will return the result code resFNotFound. A refNum of 0 represents
- the system resource file."
- ;;
- (#_UseResFile :word (refnum-alist-entry (refnum/filename->alist-entry refnum-or-filename)))
- (resource-error))
-
-
- ;;;====================================================================
- ;;;Getting resource types =============================================
- ;;;====================================================================
-
- (defun count-types ()
- "Returns the number of resource types in all open resource files."
- ;;
- (#_CountTypes :word))
-
-
- (defun get-indexed-type (index)
- "Given an index ranging from 1 to CountTypes (above), GetIndType returns
- a resource type in theType. Called repeatedly over the entire range for the
- index, it returns all the resource types in all open resource files. If the
- given index isn’t in the range from 1 to CountTypes, GetIndType returns
- four NULL characters (ASCII code 0)."
- ;;
- (ccl::%stack-block ((res-type-ptr 4))
- (#_GetIndType :ptr res-type-ptr :word index)
- (ccl::%get-ostype res-type-ptr)))
-
-
- ;;;====================================================================
- ;;;Getting and disposing of resources =================================
- ;;;====================================================================
-
- (defun count-resources (kw-resource-type)
- "CountResources returns the total number of resources of the given type
- in all open resource files."
- ;;
- (check-resource-type kw-resource-type)
- (#_CountResources kw-resource-type))
-
-
- (defun get-indexed-resource (kw-resource-type index)
- "Given an index ranging from 1 to CountResources(theType), GetIndResource
- returns a handle to a resource of the given type (see CountResources, above).
- Called repeatedly over the entire range for the index, it returns handles to
- all resources of the given type in all open resource files. GetIndResource
- reads the resource data into memory if it’s not already in memory, unless
- you’ve called SetResLoad(FALSE)."
- ;;
- (check-resource-type kw-resource-type)
- (#_GetIndResource kw-resource-type index))
-
-
- (defun get-resource (kw-resource-type resource-number)
- "Returns a handle to the resource-number'th resource of type
- kw-resource-type."
- ;;
- (check-resource-type kw-resource-type)
- (unless (numberp resource-number)
- (error "~S not a number" resource-number))
- (#_GetResource kw-resource-type resource-number))
-
-
- (defun get-named-resource (kw-resource-type resource-name)
- "Returns a handle to the resource of type kw-resource-type named
- resource-name."
- ;;
- (check-resource-type kw-resource-type)
- (ccl::with-pstrs ((resource-name-ptr resource-name))
- (#_GetNamedResource kw-resource-type resource-name-ptr)))
-
-
- (defun load-resource (h-resource)
- "Ensures the resource referenced by h-resource is in memory.
- S/call resource-error?."
- ;;
- (check-h-resource h-resource)
- (#_LoadResource :ptr h-resource) ;should dereference!?
- )
-
-
- (defun count1-resources (kw-resource-type)
- "Count1Resources returns the total number of resources of
- kw-resource-type in the current resource file."
- ;;
- (check-resource-type kw-resource-type)
- (#_Count1Resources kw-resource-type))
-
-
- (defun get1-indexed-resource (kw-resource-type index)
- "Given an index ranging from 1 to CountResources(theType),
- GetIndResource returns a handle to a kw-resource-type resource (see
- CountResources, above). Called repeatedly over the entire range for the
- index, it returns handles to all resources of the given type in the
- current resource file. Get1IndResource reads the resource data into
- memory if it's not already in memory, unless you've called
- SetResLoad(FALSE)."
- ;;
- (check-resource-type kw-resource-type)
- (#_Get1IndResource kw-resource-type index))
-
-
- ;;;====================================================================
- ;;;Getting resource information =======================================
- ;;;====================================================================
-
- (defun get-resource-info (h-resource)
- "Returns values id-number type and name of the resource referenced by
- h-resource."
- ;;
- (check-h-resource h-resource)
- (ccl::%stack-block ((id-ptr 2)
- (type-ptr 4)
- (name-ptr 256) ;right?
- )
- (#_GetResInfo :ptr h-resource :ptr id-ptr :ptr type-ptr :ptr name-ptr)
- (let ((error-code (resource-error)))
- (cond ((zerop error-code)
- (values (ccl::%get-word id-ptr)
- (ccl::%get-ostype type-ptr)
- (ccl::%get-string name-ptr)))
- (t (error "Code: ~A" error-code))))))
-
-
- (defun size-resource (h-resource)
- "Returns the size of the resource referenced by h-resource in bytes."
- ;;
- (check-h-resource h-resource)
- (#_SizeResource :ptr h-resource :long))
-
-
- ;;;====================================================================
- ;;;Modifying resources ================================================
- ;;;====================================================================
-
- (defun add-resource (h-data kw-resource-type int-id str-name)
- ;;
- (check-resource-type kw-resource-type)
- (check-h-resource h-data)
- (ccl::with-pstrs ((p-name str-name))
- (#_AddResource h-data kw-resource-type int-id p-name)))
-
-
- (defun remove-resource (h-resource)
- ;;
- (check-h-resource h-resource)
- (#_RmveResource h-resource))
-
-
- (defun update-resource-file (refnum-or-filename)
- ;;
- (#_UpdateResFile :word (refnum-alist-entry (refnum/filename->alist-entry refnum-or-filename)))
- (resource-error))
-
-
- ;;;====================================================================
- ;;;Resource printing functions ========================================
- ;;;====================================================================
-
- (defun print-info-resource-type (kw-resource-type)
- "Prints information about all resources of type kw-resource-type"
- ;;
- (let* ((number (count-resources kw-resource-type))
- id-number type name)
- (format t "~&~S resources of type ~S" number kw-resource-type)
- (dotimes (i number)
- (multiple-value-setq (id-number type name)
- (get-resource-info (get-indexed-resource kw-resource-type (1+ i))))
- (format t "~&~S:~5T~S~10T~S~20T~S" (1+ i) id-number type name))))
-
-
- (defun print-info-all-resource-types ()
- "Prints information about all resource types."
- ;;
- (let (resource number)
- (dotimes (i (count-types))
- (setf resource (get-indexed-type (1+ i))
- number (count-resources resource))
- (format t "~&~S~4Tresource~P of type~23T~S" number number
- resource))))
-
-
- ;;;====================================================================
- ;;;Utilities ==========================================================
- ;;;====================================================================
-
- (defmacro get-resource-smart (kw-resource-type id)
- "Expands to get-resource if id is an integer or get-named-resource if id
- is a string. Note: the args may be evaluated more than once."
- ;;
- `(typecase ,id
- (integer (get-resource ,kw-resource-type ,id))
- (string (get-named-resource ,kw-resource-type ,id))))
-
-
- ;;;====================================================================
- ;;;Image save/restore functions =======================================
- ;;;====================================================================
-
- (defun reopen-resource-files ()
- "Calls open-resource-file on each filename saved on
- *open-resource-files*."
- ;;
- (map nil #'(lambda (open-file-alist-entry)
- (open-resource-file (filename-alist-entry open-file-alist-entry)))
- (reverse *open-resource-files*)))
-
-
- (pushnew #'reopen-resource-files ccl::*restore-lisp-functions*
- :key #'ccl::function-name)
-
-
- ;;;
-
- (ccl::provide "RESOURCE-UTILS")